perm filename EAID.1[MAC,LSP]14 blob
sn#705203 filedate 1983-04-04 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 MacLisp Aids for E
C00016 00003 E Manipulation Routines
C00023 00004 A mapping function for E entities
C00026 00005 Sends a page of stuff, 200 liness at a time
C00027 00006 Stuff to lookup a word in UNABRD.DIC Takes a word in the attach
C00039 00007 Routines to exchange 2 pages.
C00042 00008 A routine to clean up a file.
C00048 00009 Not equals
C00050 00010 Hack to Double Column
C00052 00011 For Finding Strings
C00053 00012 For Responding to MAIL.
C00058 ENDMK
C⊗;
;;; MacLisp Aids for E
(declare (special ?e:id *e:a1 *e:a2 *e:b1 *e:b2 -em:sfa-
-em:mail-input-buffer-dry-handler-)
(setq defmacro-for-compiling ())
(muzzled t)
(*lexpr %match)
(*expr em:warn read-filename em:tyi-line em:readonly-var em:raw-ecommands
%instantiate em:tyi-message em:readonly-vars em:ecommands))
(defun e:goto (page line)
(em:ecommands (append (e:make-e-control-number page)
'(α P)
(e:make-e-control-number line)
'(α L))))
(defun e:make-e-control-number (n)
(cond ((zerop n)(list 'α 0))
(t
(let ((sign (cond ((lessp n 0) '-))))
(setq n (abs n))
(do ((i n (quotient i 10.))
(ans ()))
((zerop i) (cond (sign (push sign ans)(push 'α ans)))
ans)
(push (remainder i 10.) ans)
(push 'α ans))))))
(defun e:balance ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(let ((line (cdr (assq 'line alist)))
(lines (cdr (assq 'lines alist)))
(pages (cdr (assq 'pages alist)))
(cpage (cdr (assq 'page alist)))
(cline (cdr (assq 'line alist)))
(page (cdr (assq 'page alist))))
(em:ecommands '(α - α V))
(e:balance2 line lines page pages)
(em:ecommands (append (e:make-e-control-number cpage)
'(α p)
(e:make-e-control-number cline)
'(⊗ ↔)
'(α V)))
'done)))
(defun e:balance2 (line lines page pages)
(do ((page page (1+ page)) (cline ()))
((< pages page))
(do ((line line (1+ line)))
((< lines line)
(or (= pages page)
(em:ecommands '(α p)))
(setq line 1
lines
(cdr (assq 'lines (em:readonly-vars '(lines))))))
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(cond ((%match
'(*e:a1 ?e:id ($r ? e:lbp)
*e:b1)
(reverse cline))
(setq *e:a1 (reverse *e:a1)
*e:b1 (reverse *e:b1))
(cond ((%match
`(,@*e:b1
? ? *e:b2 ,?e:id ($r ? e:rbp) *e:a2)
cline)
(let ((balance (e:count-parens
*e:b2)))
(cond ((> balance 0)
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1 *e:b2
(e:n-parens balance)
*e:a2))
(em:ecommands '(⊗ B α // α ⊗ ↔))
(setq line (1- line)))
((< balance 0)
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append
*e:b1
(cdr (e:flush-n-parens
*e:b2
(minus balance))) *e:a2))
(em:ecommands '(⊗ B α // α ⊗ ↔))
(setq line (1- line)))
(t
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1 *e:b2 *e:a2))
(em:ecommands '(⊗ B α // α ⊗ ↔))
(setq line (1- line))))))
(t (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands (append *e:b1 *e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔))
(cond ((%match '(* ($r ? e:lbp) *) *e:a1)
(em:ecommands '(⊗ B))
(let ((?e:id ())(*e:b1 ())(*e:a1()))
(e:balance2 line lines page pages))
(e:goto page line)
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(%match `(,@*e:b1 *e:a1) cline)))
(e:balance1 ?e:id (e:count-parens *e:a1)
(1+ line) lines page pages)
(e:goto page line)
(setq line (1- line)))))
(t (em:ecommands '(⊗ ↔)))))))
(defmacro e:backup ()
`(cond ((= line 1)
(cond ((= page 1)
(print 'Not-balanced)
(*throw 'out ()))
(t (setq page (1- page))
(em:ecommands '(α - α P))
(setq lines (cdr (assq 'lines
(em:readonly-vars '(lines)))))
(setq line lines)
(em:ecommands (append
(e:make-e-control-number lines)
'(α L))))))
(t (setq line (1- line))
(em:ecommands '(⊗ B)))))
(defun e:balance1 (id n line lines page pages)
(let ((cline ()))
(*catch 'done
(do ((page page (1+ page)))
((< pages page)
(print 'Not-balanced))
(do ((line line (1+ line)))
((< lines line)
(or (= page pages)
(em:ecommands '(α p)))
(setq line 1
lines
(cdr (assq 'lines (em:readonly-vars '(lines))))))
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(cond ((%match '(* ($r ? e:lbp) *) cline)
(let ((?e:id ())(*e:b1 ())(*e:a1 ())(*e:b2 ())(*e:a2 ()))
(e:balance2 line lines page pages))
(e:goto page line)))
(cond ((%match `(*e:b1 ,id ($r ? e:rbp) *e:a1)
cline)
(let ((balance (+ n (e:count-parens
*e:b1))))
(cond ((> balance 0)
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1
(e:n-parens balance)
*e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔)))
((< balance 0)
(prog ()
again
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(let ((n
(e:flush-n-parens *e:b1
(minus balance))))
(em:raw-ecommands
(append
(cdr n)
*e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔))
(cond ((= (car n) 0) (return t))
(t
(e:backup)
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(setq *e:b1 cline
*e:a1 ())
(go again))))))
(t
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1 *e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔)))))
(*throw 'done t))
(t (em:ecommands '(α // ⊗ ↔))
(setq n (+ n (e:count-parens cline))))))))))
(defun e:count-parens (l)
(do ((l l (cdr l))
(n 0))
((null l) n)
(cond ((e:lpp (car l))
(setq n (1+ n)))
((e:rpp (car l))
(setq n (1- n)))
((e:scp (car l)) ;semi-colon
(return n)))))
(defun e:n-parens (n)
(do ((n n (1- n))
(ans ()))
((= n 0) ans)
(push #o51 ans)))
(defun e:flush-n-parens (l n)
(do ((l l (cdr l))
(a ()))
((or (null l)
(e:scp (car l)))
(do ((a a (cdr a))
(quit ())
(ans ())
(n n))
((or quit (= n 0)) `(,n . ,(append (reverse a) ans l)))
(cond ((e:rpp (car a))
(setq n (1- n)))
((null a)
(setq quit t))
(t (push (car a) ans)))))
(push (car l) a)))
(defun e:scp (n)(= n #o73))
(defun e:lpp (n)(= n #o50))
(defun e:rpp (n)(= n #o51))
(defun e:lbp (n)(= n #o133))
(defun e:rbp (n)(= n #o135))
(declare (special e:line e:lines e:page e:pages))
(defun e:send-next-line ()
(let ((-em:mail-input-buffer-dry-handler- ()))
(cond ((= e:lines e:line)
(cond ((= e:page e:pages)
(break |No right paren found| t))
(t (em:ecommands
'(α p))
(setq e:line 1
e:page (1+ e:page)
e:lines
(cdr (assq 'lines
(em:readonly-vars '(lines)))))
(em:ecommands '(α =)))))
(t (em:ecommands '(⊗ ↔ α =))
(setq e:line (1+ e:line))))))
(defun e:send-this-line ()
(let ((-em:mail-input-buffer-dry-handler- ()))
(cond ((< e:lines e:line)
(cond ((= e:page e:pages)
(break |No right paren found| t))
(t (em:ecommands
'(α p))
(setq e:line 1
e:page (1+ e:page)
e:lines
(cdr (assq 'lines
(em:readonly-vars '(lines)))))
(em:ecommands '(α =)))))
(t (em:ecommands '(α = ⊗ ↔))
(setq e:line (1+ e:line))))))
;;; SEXP on next line
(defun e:eval-next-sexp ()
(em:ecommands '(α β - α β V))
(e:eval-next-sexp1)
(em:ecommands '(α β V)))
(defun e:eval-next-sexp1 ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq e:line (cdr (assq 'line alist))
e:lines (cdr (assq 'lines alist))
e:page (cdr (assq 'page alist))
e:pages (cdr (assq 'pages alist))))
(let ((-em:mail-input-buffer-dry-handler- 'e:send-next-line))
(print (eval (read)))))
;;; SEXP on this line
(defun e:eval-this-sexp ()
(em:ecommands '(α β - α β V))
(e:eval-this-sexp1)
(em:ecommands '(α β V)))
(defun e:eval-this-sexp1 ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq e:line (cdr (assq 'line alist))
e:lines (cdr (assq 'lines alist))
e:page (cdr (assq 'page alist))
e:pages (cdr (assq 'pages alist))))
(cond ((< e:lines e:line)(setq e:line (1- e:line))
(em:ecommands '(⊗ ↑))))
(let ((-em:mail-input-buffer-dry-handler- 'e:send-this-line))
(print (eval (read)))))
;;; E Manipulation Routines
;;; These are to help the user edit his MacLisp file.
;;; This routine sends the current sexp no matter where you
;;; are as long as you are `inside' of it
(defun e:send-this-defun ()
(em:ecommands '(α β - α β V))
(e:find-defun-backwards);find the previous defun, defmacro...
(e:eval-this-sexp1) ;evaluate it
(em:ecommands '(α β V)))
(defun e:find-enclosing-defun ()
(em:ecommands '(α - α v))
(e:find-defun-backwards)
(em:ecommands '(α - α v))
'done)
(defun e:find-defun-backwards ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq e:line (cdr (assq 'line alist))
e:lines (cdr (assq 'lines alist))
e:page (cdr (assq 'page alist))
e:pages (cdr (assq 'pages alist)))
(cond ((< e:lines e:line)(setq e:line (1- e:line))
(em:ecommands '(⊗ ↑))))
(*catch 'e:find-defun-backwards
(do ((e:page e:page (1- e:page)))
((< e:page 1) (break |Defun not found| t))
(do ((e:line e:line (1- e:line)))
((< e:line 1))
(em:ecommands '(α =))
(cond ((e:defun-on-this-linep (em:tyi-message))
(*throw 'e:find-defun-backwards t)))
(em:ecommands '(⊗ b)))
(em:ecommands '(α - α p α ∞ ⊗ ↔ ⊗ b))
(setq e:lines (cdr (assq 'lines (em:readonly-vars '(lines)))))
(setq e:line e:lines)))))
;;; For now it looks for:
;;; (defun
;;; (defmacro
;;; (macro
;;; (match-macro
;;; (macrodef
(defun e:defun-on-this-linep (text)
(or
(%match '(* #o50 ($ir * e:spacep)
($r ? e:dp)
($r ? e:ep)
($r ? e:fp)
($r ? e:up)
($r ? e:np) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:dp)
($r ? e:ep)
($r ? e:fp)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:mp)
($r ? e:ap)
($r ? e:tp)
($r ? e:cp)
($r ? e:hp)
($r ? e:-p)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op)
($r ? e:dp)
($r ? e:ep)
($r ? e:fp) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op) ($r ? e:spacep) *) text)))
(defun e:white-spacep (n) (or (= n #o40)
(= n #o11)))
(defun e:not-white-spacep (n) (not (or (= n #o40)
(= n #o11))))
(defun e:dp (n) (or (= n #o104)
(= n #o144)))
(defun e:ep (n) (or (= n #o105)
(= n #o145)))
(defun e:fp (n) (or (= n #o106)
(= n #o146)))
(defun e:up (n) (or (= n #o125)
(= n #o165)))
(defun e:np (n) (or (= n #o116)
(= n #o156)))
(defun e:mp (n) (or (= n #o115)
(= n #o155)))
(defun e:ap (n) (or (= n #o101)
(= n #o141)))
(defun e:cp (n) (or (= n #o103)
(= n #o143)))
(defun e:rp (n) (or (= n #o122)
(= n #o162)))
(defun e:op (n) (or (= n #o117)
(= n #o157)))
(defun e:tp (n) (or (= n #o124)
(= n #o164)))
(defun e:hp (n) (or (= n #o110)
(= n #o150)))
(defun e:-p (n) (= n #o55))
(defun e:semip (n)(= n #o73))
(defun e:spacep (n)(= n #o40))
(defun e:letterp (n)
(or (and (< #o100 n)
(< n #o133))
(and (< #o140 n)
(< n #o173))))
(defun e:digitp (n)(and (< #o57 n)(< n #o72)))
(defun e:digit-letterp (n)
(or (e:letterp n)
(e:digitp n)))
(defun e:not-digit-letterp (n)
(not (or (e:letterp n)
(e:digitp n))))
(defun e:tabp (n) (= n #o11))
(defun e:langlep (n)(= n #o74))
(defun e:ranglep (n)(= n #o76))
(defun e:@p (n)(= n #o100))
;;; A mapping function for E entities
;;; NIL result for fun means stay on current line, number means go up or down
;;; that amount. T means next line.
(defun e:page-map (fun)
(em:ecommands '(α - α V α L))
(do ((line (em:readonly-var 'line)) (result))
((< (em:readonly-var 'lines) line) (em:ecommands '(α V)) 'done)
(em:ecommands '(α =))
(setq result (funcall fun (em:tyi-message)))
(cond ((numberp result)
(em:ecommands
(append
(e:make-e-control-number result) '(⊗ ↔)))
(setq line (+ line result)))
(result (setq line (1+ line))
(em:ecommands '(⊗ ↔))))))
(defun e:set-current-line (cline)
(em:raw-ecommands (append '(#o2 #o113 #o26 #o27)
cline '(#o26 #o102))))
(declare (special e:productions))
;;; Does not need the crlf at the end of the line in the production
(defun e:crlf () '(#o15 #o12))
(setq e:productions
`(((*st ($ir *sp e:white-spacep) ($r ? e:digit-letterp)
($ir *junk e:digit-letterp) ,@(e:crlf))
(*st))))
(defun e:ponder-line (line)
(do ((l e:productions (cdr l)))
((null l) t)
(cond ((%match (caar l)
line)
(em:raw-ecommands (append '(#o2 #o113 #o26 #o27)
(%instantiate (cadar l))
'(#o2 #o26 #o27)))))))
(defun e:transform-page () (e:page-map #'e:ponder-line))
;;; Sends a page of stuff, 200 liness at a time
(comment
(defun e:send-page ()
(let ((lines (cdr (assq 'lines (em:readonly-vars '(lines))))))
(let ((n (quotient lines 200.)))
(em:ecommands '(α - α V α L))
(cond ((not (= 0 (remainder lines 200.)))
(setq n (1+ n))))
(do ((i n (1- i)))
((= i 0) (em:ecommands '(α V)) 'done)
(em:ecommands '(α 2 α 0 α 0 α = α 0 α = 0 ⊗ ↔))
(read)
(em:ecommands '(α 2 α 0 α 0 ⊗ ↔))))))
)
;;; Stuff to lookup a word in UNABRD.DIC Takes a word in the attach
;;; buffer and say αz F
(declare (special e:dir-h))
(array e:unabrd t 235.)
(do ((l
'(A accordantly actinomeric advisal agitation alem altaite ampelotherapy
ancillary anodendron anticritique Aonian apron argel Ascetta atechnical
autocephality azotate balloonful basisphenoid beerhouse beprose Bidens
bitterwood board Bothrodendron breediness Buchnera by calotermitid
capripede caryatic cecidiologist Cestida cheese choanosome churchman clart
coagitator cointense commot confinedness contorsive corke counterbuff
crateman cruroinguinal curvy dacryocystosyringotomy debatingly degradement
denudate detergence dicetyl diplacusis disharmonism Ditremidae dosimetrist
dualin ebulus elderbrotherhood emetomorphine enforcer Epanorthidae
equivocal ethnogeographer exceptionality extending fanfare ferreting
firelock floriculture foregleam frangula funambulator gamont Gemmingia
gigglingly glycogenize gracilis grooveless gymnurine hangar heaviness
hemoconcentration heteronomy histotrophy hoof huntilite hyostylic
hypotrachelium illocality impregnant incubous inferringly insense
interjaculate intrarelation irreportable Jacamerops jonque Kawchodinne
klipdas lackadaisical larrigan lehr lienopancreatic lithopedium lougheen
Maba malapropoism marcello maxillojugal mellifluent Mesosauria
microbrachius minding misspend monkism moringaceous multifold myitis
nasicorn nephology nineteenfold nonconformance nonliquidation
nonsympathizer numerator octan ombrophyte opsonic orthotypous outjest
overdaintiness overrealism oxyphile palinody papion parling pauperess
penetrator perigone pet Philodinidae phrenomagnetism piglet Placoidei
pleurogenous poison polysyllabically postexilian preallotment predwell
preprudent primevity progressionism protectible pseudocultural pucka
Pygopodes quatrayle radiolucency reaccord recondense refreshen remitment
reservedness retrovert ribbed Romescot rundale salicylic Sarothra schematic
scranny Seder seminase sergeantship Sharia shrinal sinewiness slangish
snakeproof solvend sparver spinsterism spumification statesmanlike stimy
strident subcrepitant substandardize sulphureously superpraise swan
synergize tamandu tawdered tenantless tetrapody thermoneutrality thurify
titleboard torulose transformism trichloride tritonymphal Tuesday type
unadventurously unblossomed uncompliableness undenominationalize
undescript unerected unfrounced uniformal unleafed unobediently
unpretendingness unreticent unskirted untantalized unwearying urethralgia
vanadous verdureless violent vulvovaginitis waxing whirroo witloof
xanthophyllous zac)
(cdr l))
(i 0 (+ i 1)))
((null l)(setq e:dir-h (- i 1)))
(store (e:unabrd i) `(,(car l) . ,(+ i 2))))
(defmacro dword (n) `(car (e:unabrd ,n)))
(defmacro dpage (n) `(cdr (e:unabrd ,n)))
(defun e:word-lookup (word)
(cond ((> (em:readonly-var 'attsiz)
0)
(em:ecommands '(α β K))))
(em:ecommands (append '(α ε u n a b r d // d //)
(let ((base 10.)( *nopoint t))
(explode (e:bin-search word)) )
'(p ⊗ ↔)))
(em:ecommands (append '(α β F) (explode word) '(⊗ ↔)))
'done)
(defun e:fast-word-lookup (word)
(cond ((> (em:readonly-var 'attsiz)
0)
(em:ecommands '(α β K))))
(em:ecommands (append '(α g)
(e:make-e-control-number
(e:bin-search word))
'(α p ⊗ ↔)))
(em:ecommands (append '(α β F) (explode word) '(⊗ ↔)))
'done)
(defun e:word-lookup-here (word)
(cond ((> (em:readonly-var 'attsiz)
0)
(em:ecommands '(α β K))))
(em:ecommands (append (e:make-e-control-number
(e:bin-search word))
'(α p ⊗ ↔)))
(em:ecommands (append '(α β F) (explode word) '(⊗ ↔)))
'done)
(defun e:Bin-search (word)
(let ((low 0)
(high e:dir-h))
(do ((mid (// (+ low high) 2)
(// (+ low high) 2)))
((not (< low high))
(dpage low))
(cond ((eq (dword mid)
word)
(return (dpage mid)))
((alphalessp (dword mid) word)
(cond ((eq (dword (+ mid 1)) word)
(return (dpage (+ mid 1))))
((alphalessp word (dword (+ mid 1)))
(return (dpage mid)))
(t (setq low (+ mid 1)))))
(t (setq high (- mid 1)))))))
;;; Routines to exchange 2 pages.
(defun ↔ fexpr (x)
(let ((n (car x))
(m (cadr x)))
(cond ((null m)(setq m n)(setq n ())))
(cond
((and (null n)(null m)))
(t
(do ((x (cdr n) (cdr x))
(y (cdr m) (cdr y))
(max (or (car n) (car m)))(min (or (car n)(car m))))
((and (null x)(null y))
(setq n (do ((i max (- i 1))
(l () `(,i . ,l)))
((< i min) l))))
(setq min (min min (or (car x) min)(car y)))
(setq max (max max (or (car x) max)(car y))))
(em:ecommands '(α - α v))
(cond ((numberp n)(e:exchange n m))
(t (let ((map (mapcar #'(lambda (x) `(,x . ,x)) n)))
(do ((n n (cdr n))
(m m (cdr m)) (pos1)(pos2))
((or (null n)(null m)) 'done)
(setq pos1 (assoc (car m) map))
(setq pos2 (do ((map map (cdr map))
(x (car n)))
((null map) ())
(cond ((= x (cdr (car map)))
(return (car map))))))
(cond ((= (car n) (cdr pos1)))
(t
(e:exchange (car n)(cdr pos1))
(rplaca pos1 (prog1 (car pos2)
(rplaca pos2 (car pos1))))))))))
(em:ecommands '(α v))))))
(defun e:exchange (n m)
(let ((ln 0)
(lm 0)
(current-page (em:readonly-var `page)))
(e:goto n 1)
(setq ln (em:readonly-var 'lines))
(em:ecommands (append
(e:make-e-control-number ln)
'(α A)))
(e:goto m 1)
(setq lm (em:readonly-var 'lines))
(em:ecommands (append '(α e)
(e:make-e-control-number ln)
'(⊗ ↔)
(e:make-e-control-number lm)
'(α a)))
(e:goto n 1)
(em:ecommands (append
'(α e)
(e:make-e-control-number current-page)
'(α p)))
'done))
;;; A routine to clean up a file.
;;; The following commands on the first line of a page dispose
;;; of that page:
;;; ↓ deletes page
;;; →<filename> sends that page to the end of the file indicated
(declare (special e:activity))
(defun e:dispose-file ()
(em:ecommands '(α - α V))
(let ((vars (em:readonly-vars '(page pages))))
(do ((pages (- (+ 1 (cdr (assq 'pages vars)))
(cdr (assq 'page vars)))
(- pages 1))
(e:activity ())
(winners '(())))
((= pages 0) (em:ecommands '(α 1 α p α v))
(cond ((null e:activity)
(terpri)
(princ '|No changes to file.|)
(terpri)))
'done)
(e:dispose-page (not (= pages 1)) winners))))
(defun e:dispose-page (flag winners) ;go to next page flag
(cond ((not (= (em:readonly-var 'lines) 0))
(let ((line (em:tyi-line)))
(do ((l line (cdr l)))
((not (member (car l)
'(#o15 #o12 #o40 #o21)))
(setq line l)))
(cond ((= (car line) 1) ;↓
(setq e:activity t)
(e:delete-page))
((= (car line) 25.) ;→<filename>
(setq e:activity t)
(em:ecommands '(α k → α D α ⊗ ↔ α =))
(let ((file (car (read-filename ()))))
(cond ((or (member file (cdr winners))
(cond ((probef file)
(nconc winners (ncons file))
t)))
(em:ecommands '(α β D))
(cond ((= (em:readonly-var 'lines) 0)
(em:ecommands '(α ∂ α β D)))
(t (e:move-page-to-file file)) ))
(t (em:ecommands '(β → α ⊗ ↔))
(em:warn
(implode (append
(explode file)
'(| | |n| |o| |t| | | |f| |o| |u| |n| |d|))))
(cond (flag (em:ecommands '(α p))))))))
(flag (em:ecommands '(α p))))))
(flag (em:ecommands '(α p)))))
(defun e:delete-page ()
(em:ecommands (append (e:make-e-control-number (em:readonly-var 'lines))
'(α β D α ∂ α β D))))
;;; file looks like ((dsk (aid rpg)) foo bar)
(defmacro file-filename (file) `(cadr ,file))
(defmacro file-extension (file) `(caddr ,file))
(defmacro file-project (file) `(car (cadr (car ,file))))
(defmacro file-programmer (file) `(cadr (cadr (car ,file))))
(defmacro flush-slashes (l)
`(mapcan (function (lambda (x) (cond ((eq x '//) ())
(t (ncons x)))))
,l))
(defun e:move-page-to-file (file)
(em:ecommands (append (e:make-e-control-number (em:readonly-var 'lines))
'(α A α ε)
(flush-slashes (explode (file-filename file)))
(cond ((not (eq (file-extension file)
'←←←))
(append '(/.)
(flush-slashes (explode (file-extension file))))))
'(/[)
(flush-slashes (explode (file-project file)))
'(/,)
(flush-slashes (explode (file-programmer file)))
'(/] // e ⊗ ↔ α X M A R K ⊗ ↔ α H α ∂ α β D))))
(defun e:switch-file (file)
(em:ecommands (append '(α ε)
(flush-slashes (explode (file-filename file)))
(cond ((not (eq (file-extension file)
'←←←))
(append '(/.)
(flush-slashes (explode (file-extension file))))))
'(/[)
(flush-slashes (explode (file-project file)))
'(/,)
(flush-slashes (explode (file-programmer file)))
'(/] // e ⊗ ↔))))
;;; Not equals
(defun e:not-equals (x)
(cond
((numberp x)
(e:not-equals-number1 x))
((atom x)
(do ((v (e:not-equals-atom1 x)
(e:not-equals-atom1 x)))
(v v)))
((hunkp x) (let ((l (hunksize x))
(h ()))
(setq h (makhunk l))
(do ((i 0 (1+ i)))
((= i l) h)
(rplacx i h (e:not-equals (cxr i x))))))
(t (mapcar #'e:not-equals x)))))
(defun e:not-equals-atom1 (x)
(let ((n (random (cadr (arraydims obarray))))
(flag ())
(i 0))
(*catch 'out
(mapatoms
#'(lambda (y)
(cond ((not flag)
(cond ((= i n)
(setq flag t))
(t (setq i (1+ i)))))
((not (eq x y))
(*throw 'out y))))))))
(defun e:not-equals-number1 (x)
(do ((i (random 1000.)(random 1000.)))
((not (= x i)) i)))
undine
;;; Hack to Double Column
(defun e:double ()
(let ((n (em:readonly-var 'attsiz)))
(let ((hn (// n 2))
(oddp ()))
(cond ((= n (* hn 2)))
(t (setq oddp t)))
(em:ecommands (append
'(α - α V α E)
(cond (oddp
(e:make-e-control-number (1+ hn)))
(t (e:make-e-control-number hn)))
'(⊗ ↔)
(e:make-e-control-number hn)
'(α A)))
(cond (oddp
(em:ecommands '(⊗ ↑))))
(do ((i hn (1- i)))
((= i 0)
(do ((i hn (1- i)))
((= i 0)
(em:ecommands '(α V))
'done)
(em:ecommands '(α ⊗ = α d β ⊗ = ⊗ ↔))))
(em:ecommands '(α - α a ⊗ ↑))))))
;;; For Finding Strings
(declare (special e:search-string))
(setq e:search-string ())
(defun e:set-string (string)
(setq e:search-string string)
t)
(defun e:find-string ()
(em:ecommands (append
'(α F)
(explode e:search-string)
'(⊗ ↔)))
t)
(defun e:xfind-string ()
(em:ecommands (append
'(α x F | |)
(explode e:search-string)
'(⊗ ↔)))
t)
(defun e:report-string () e:search-string)
;;; For Responding to MAIL.
(declare (special e:mail-headers *site *name *junk *subject))
(setq e:mail-headers
'((* ($r ? e:langlep) ($ir *name e:not-white-spacep)
($ir * e:white-spacep)
($r ? e:ap) ($r ? e:tp) ($ir * e:white-spacep)
($ir *site e:not-white-spacep)($r ? e:ranglep)
*subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep)
($ir * e:white-spacep)
($r ? e:ap) ($r ? e:tp) ($r ? e:white-spacep)
($ir * e:white-spacep)
($ir *site e:not-white-spacep)
($ir * e:white-spacep)
#o50 * #o51
($ir * e:white-spacep)
($r ? e:rp) ($r ? e:ep) #o72
($r ? e:white-spacep) *subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep)
($ir * e:white-spacep)
($r ? e:ap) ($r ? e:tp) ($r ? e:white-spacep)
($ir * e:white-spacep)
($ir *site e:not-white-spacep)
($r ? e:white-spacep) *subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep) ($r ? e:@p)
($ir *site e:not-white-spacep) ($r ? e:white-spacep) *subject)
(* #o11 #o61 #o60 #o60 ($ir * e:white-spacep) #o72
($ir * e:white-spacep) ($ir *name e:not-white-spacep)
($r ? e:white-spacep) *subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep)
($r ? e:white-spacep) *subject)
))
;;; Returns entire page to sender
(defun e:respond-mail ()
(em:ecommands '(α - α v))
(let ((attsiz (em:readonly-var 'attsiz))
(linenum ()))
(cond ((= attsiz 0))
(t (em:ecommands '(α E))
(setq linenum (em:readonly-var 'line))))
(em:ecommands '(α l))
(let ((line (em:tyi-line)))
(do ((l e:mail-headers (cdr l))
(*name ())(*site ())(*subject ()))
((null l) (em:ecommands '(α v))
'Huh?)
(cond ((%match (car l)
line)
(cond ((not (= attsiz 0))
(em:ecommands
(append
(e:make-e-control-number (1- linenum))
'(⊗ ↔)
(e:make-e-control-number attsiz)
'(α a)))))
(em:raw-ecommands
(append
'(#o2 #o130 #o115 #o101 #o111 #o114 #o57 #o123
#o125 #o40)
*name
(cond (*site '(#o100)))
(cond (*site))
'(#o40)
(e:condition-subject *subject)
'(#o26 #o27)))
(cond ((not (= attsiz 0))
(em:ecommands '(α E))))
(em:ecommands '(α V))
(return 'done)))))))
(defun e:condition-subject (l)
(do ((x l (cdr x)))
((e:not-white-spacep (car x)))
(setq l (cdr l)))
(%match `(*junk ,@(e:crlf)) l)
(setq *junk (reverse *junk))
(do ((x *junk (cdr x)))
((e:not-white-spacep (car x))
(reverse *junk))
(setq *junk (cdr *junk))))